home *** CD-ROM | disk | FTP | other *** search
/ MacWorld 1997 September / Macworld (1997-09).dmg / Serious Software / Cherwell Scientific Demos / pro Fit / pro Fit 5.0 demo (fpu).sea / pro Fit 5.0 demo (fpu) / Functions & Programs / BlockChart next >
Text File  |  1996-06-02  |  7KB  |  223 lines
  1. { This program draws a three-dimensional block chart of a two-dimensional scalar }
  2. { field z(x,y). }
  3. { The x- and y-coordinates of the field correspond to column and row }
  4. { numbers. The z coordinate is given by the value in a given row/column. }
  5. { To use the program, choose "Add to Menu" from the Misc menu to compile it }
  6. { Then open a data window (if none is open). Then run the program by choosing }
  7. { "BlockChart" from the misc menu. }
  8.  
  9. program BlockChart;
  10.  
  11.  { First we define all the variables we need }
  12. var dataWindID, drawWindID;
  13.                 i, j;
  14.                 nr, mean, med, min, max;
  15.                 ph, pv, phh, pvv, thick, norm;
  16.                 posH, posV;           { absolute position }
  17.                 totH, totV;     { maximum width, height }
  18.                 disH, disV;     { distance between 2 bars }
  19.                 phi, theta;     { the angles of 3-D effect (phi is in plane) }
  20.                 phi0, theta0;   { the same in degrees }
  21.                 fcol, lcol;                    { first and last column to be drawn }
  22.                 frow, lrow;     { first and last row to be drawn }
  23.                 drawGrid;                            { draws the grid if not 0 }
  24.                 color1, color2; { items in color menus to be selected }
  25.                 colRED, colGREEN, colBLUE: array[1..12];
  26.  
  27. procedure Initialize;
  28.  { This routine is called once when the program is added to }
  29.  { pro Fit's menus. }
  30.  { We use it to initialize several global variables. }
  31. begin
  32.   posH := 220; posV := 100;
  33.   totH := 220; totV := 200;
  34.   thick := 10;
  35.   phi0 := 45;
  36.   theta0 := 30;
  37.   color1 := 2;
  38.   color2 := 7;
  39.   drawGrid := 1;
  40.         fcol := 1; lcol := 2;
  41.   frow := 1; lrow := 5;
  42.   
  43.   { The following is a color table. It could be easily extended if necessary. }
  44.   colRED[1]  := 65535; colGREEN[1]  := 0;     colBLUE[1]  := 65535;    { magenta }
  45.   colRED[2]  := 0;     colGREEN[2]  := 0;     colBLUE[2]  := 65535;    { blue }
  46.   colRED[3]  := 0;     colGREEN[3]  := 65535; colBLUE[3]  := 65535;    { cyan }
  47.   colRED[4]  := 0;     colGREEN[4]  := 32767; colBLUE[4]  := 8191;     { dark green }
  48.   colRED[5]  := 0;     colGREEN[5]  := 65535; colBLUE[5]  := 0;        { light green }
  49.   colRED[6]  := 65535; colGREEN[6]  := 65535; colBLUE[6]  := 0;        { yellow }
  50.   colRED[7]  := 65535; colGREEN[7]  := 32767; colBLUE[7]  := 0;        { orange }
  51.   colRED[8]  := 65535; colGREEN[8]  := 0;     colBLUE[8]  := 0;        { red }
  52.   colRED[9]  := 65535; colGREEN[9]  := 65535; colBLUE[9]  := 65535;    { white }
  53.   colRED[10] := 49150; colGREEN[10] := 49150; colBLUE[10] := 49150;    { light grey }
  54.   colRED[11] := 32767; colGREEN[11] := 32767; colBLUE[11] := 32767;    { grey }
  55.   colRED[12] := 16383; colGREEN[12] := 16383; colBLUE[12] := 16383;    { dark grey }
  56. end;
  57.  
  58. { We define a local procedure to set the different shades of color. }
  59. procedure CalcSetFitColor(len,mode);
  60. var thecolor, redC, blueC, greenC;
  61. begin
  62.   if len < 0 then
  63.     thecolor := color2
  64.   else
  65.     thecolor := color1;
  66.   redC := colRED[thecolor]-mode*1000; if (redC < 0) then redC := 0;
  67.   greenC := colGREEN[thecolor]-mode*1000; if (greenC < 0) then greenC := 0;
  68.   blueC := colBLUE[thecolor]-mode*1000; if (blueC < 0) then blueC := 0;
  69.   SetFillColor(redC, greenC, blueC);
  70. end;
  71.  
  72. { This procedure does the mapping of 3-D coordinates onto the }
  73. { screen coordinates }
  74. procedure Do3Dto2D(col, row, dep, hor, z, doline);
  75. var alpha, radius, x, y;
  76. begin
  77.   x := row*disH + hor;
  78.   y := col*disV + dep;
  79.   if x = 0 then
  80.     if y < 0 then
  81.             alpha := 1.5*π
  82.           else
  83.             alpha := π/2
  84.         else
  85.     alpha := arctan(y/x);
  86.   if x < 0 then
  87.     alpha := alpha + π;
  88.   alpha := alpha + phi;
  89.   radius := sqrt(x*x + y*y);
  90.   phh := posH + radius*cos(alpha);
  91.   pvv := posV + radius*sin(alpha)*sin(theta) - z*cos(theta);
  92.   if doline then
  93.     LineTo(phh, pvv)
  94.   else
  95.     MoveTo(phh, pvv);
  96. end;
  97.  
  98. { Draws all negative or all positive bars, depending on the parameter sign. }
  99. procedure DrawCharts(sign);
  100. var len;
  101. begin
  102.  SetFillPattern(2);        { full color }
  103.   for i:= fcol to lcol do
  104.     begin
  105.       GroupBegin;
  106.          for j:= frow to lrow do
  107.           if dataOK(j,i) then
  108.             begin
  109.                     len := data[j,i] * norm;
  110.                     if ((len < 0) and (sign < 0)) or ((len >= 0) and (sign > 0)) then
  111.                     begin
  112.                       CalcSetFitColor(len,0);
  113.                       Do3Dto2D(i-fcol, j-frow, thick, thick, 0, 0);
  114.                 OpenPoly(0, true);
  115.                 Do3Dto2D(i-fcol, j-frow, thick, -thick, 0, 1);
  116.           Do3Dto2D(i-fcol, j-frow, thick, -thick, len, 1);
  117.           Do3Dto2D(i-fcol, j-frow, thick, thick, len, 1);
  118.           ClosePoly;
  119.           CalcSetFitColor(len,20);
  120.           Do3Dto2D(i-fcol, j-frow, thick, thick, 0, 0);
  121.                 OpenPoly(0, true);
  122.                 Do3Dto2D(i-fcol, j-frow, -thick, thick, 0, 1);
  123.                 Do3Dto2D(i-fcol, j-frow, -thick, thick, len, 1);
  124.                 Do3Dto2D(i-fcol, j-frow, thick, thick, len, 1);
  125.           ClosePoly;
  126.           CalcSetFitColor(len,5);
  127.           if len < 0 then
  128.             len := 0;
  129.           Do3Dto2D(i-fcol, j-frow, thick, thick, len, 0);
  130.                 OpenPoly(0, true);
  131.                 Do3Dto2D(i-fcol, j-frow, thick, -thick, len, 1);
  132.                 Do3Dto2D(i-fcol, j-frow, -thick, -thick, len, 1);
  133.                 Do3Dto2D(i-fcol, j-frow, -thick, thick, len, 1);
  134.           ClosePoly;
  135.         end;
  136.       end;
  137.     GroupEnd;
  138.   end;
  139. end;
  140.  
  141. { Draws a line grid at value 0. }
  142. procedure DrawTheGrid;
  143. begin
  144.  GroupBegin;
  145.  for i:= fcol to lcol do
  146.     begin
  147.       Do3Dto2D(i-fcol, 0, 0, 0, 0, 0);
  148.       Do3Dto2D(i-fcol, lrow-frow, 0, 0, 0, 1);
  149.  end;
  150.  for j:= frow to lrow do
  151.     begin
  152.       Do3Dto2D(0, j-frow, 0, 0, 0, 0);
  153.       Do3Dto2D(lcol-fcol, j-frow, 0, 0, 0, 1);
  154.  end;
  155.  GroupEnd;
  156. end;
  157.  
  158. { Main program }
  159. begin
  160.   dataWindID := GetCurrentWindow(dataType);      { check for a data window }
  161.   if (dataWindID = 0) then
  162.   begin
  163.     Alert('There is no data to be drawn.');
  164.           Halt;
  165.         end;
  166.   drawWindID := FrontmostWindow(drawingType);    { check for a drawing window }
  167.   if (drawWindID = 0) then
  168.   begin
  169.           NewWindow(drawingType);                   { open a new one if necessary }
  170.           drawWindID := FrontmostWindow(drawingType);
  171.     if (drawWindID = 0) then
  172.     begin
  173.       Alert('Could not open a new drawing window.');
  174.             Halt;
  175.           end;
  176.   end
  177.         else
  178.           BringWindowToFront(drawWindID);
  179.   
  180.         Input('$CFirst column', fcol, '$CLast column', lcol,
  181.           'First row', frow, 'Last row', lrow,
  182.           '$Pmagenta;blue;cyan;dark green;light green;yellow;orange;red;white;light gray;gray;dark gray$Color if positive', color1,
  183.           '$Pmagenta;blue;cyan;dark green;light green;yellow;orange;red;white;light gray;gray;dark gray$Color if negative', color2);
  184.   if (lrow <= frow) then
  185.        disH := totH
  186.      else
  187.        disH := totH / (lrow - frow);
  188.   if (lcol <= fcol) then
  189.        disV := totV
  190.      else
  191.        disV := totV / (lcol - fcol);
  192.   
  193.         Input('Rotation angle', phi0, 'Slant angle', theta0, 'Thickness', thick, '$XDraw line grid', drawGrid);
  194.   phi := phi0*π/180;
  195.   theta := theta0*π/180;
  196.   if phi > π then phi := π/2;
  197.   if phi < 0 then phi := 0;
  198.   if theta > π then theta := π/3;
  199.   if theta < 0 then theta := 0;
  200.  
  201.   SelectCells(fcol, frow, lcol, lrow);
  202.   if CalcStat(0,true,true,false,true) then        { calculate the maximum and minimum }
  203.   begin
  204.     GetMedian(nr,mean,med,min,max);
  205.     
  206.     norm := 120;              { normalize the height of the bars }
  207.     if -min > max then
  208.       norm := -norm/min
  209.     else
  210.       norm := norm/max;
  211.     
  212.     SetLineColor(0, 0, 0);    { start drawing }
  213.     GroupBegin;
  214.     DrawCharts(-1);
  215.     if drawGrid then
  216.             DrawTheGrid;
  217.     DrawCharts(1);
  218.     GroupEnd;
  219.   end
  220.   else
  221.     Alert('Statistical preparation failed.');
  222. end;
  223.